perm filename BMSTF.OLD[XX,LCS] blob
sn#207668 filedate 1976-03-24 generic text, type T, neo UTF8
00100 C**** BMSTF, BMS, METER, RNOTE, MAKNUM, IABS, DRWNT, RHORZ, RDRAW
00200 C ********** WHOLE & HALF RESTS, BEAMS ******
00300 SUBROUTINE BMSTF
00400 IMPLICIT INTEGER(A-Q,S-Z)
00500 REAL DIS,DISX,HGT,POS,CENTR,STFF,HGT1
00600 COMMON/STF/RSTFAC(-3/4),RSTJ2/MIN/MINI,RMINI
00700 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/BM/RA,RC,RJY
00800 COMMON/POSI/STFF(-3/4),JJ2,POS/PLTR/PLT,RHT,DIS
00900 COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
01000 1 RJA,YY,DISX,HGT,RZ,INP(53)
01100 EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3))
01200 1,(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
01300 1,(J11,JQ(9)),(J6,JQ(4)),(R9,RJQ(7)),(R8,RJQ(6)),(R3,RJQ(1))
01400 1 ,(R7,RJQ(5)),(R4,RJQ(2)),(R9,RJQ(7)),(R10,RJQ(8)),(RX3,RJQ(20))
01500 DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,R2HGT/96.0/,RBM/.83/
01600 C RDBR IS SPACER FOR DBL BAR.
01700 C RTF COMPENSATES FOR BAD PLANNING.
01710 IF(JA.NE.8)GO TO 100
01720 CALL STAFF
01730 RETURN
01800 100 RST7=RSTJ2*7.
01900 RST18=RSTJ2*18.
02000 C TO COMPENSATE FOR NOTE #3 COMING AT POS=0
02100
02200 R3Q=R3
02400 C NEXT IS FOR BEAMS
02500 RMINI=RSTJ2
02600 RX=2.7*RSTJ2*5.96
02700 C******************************
02800 R6=RHORZ(R6)
02900 IF(R8.NE.0)GO TO 204
03000 IF(R10.GE.10)GO TO 204
03100 IF(J7)GO TO 204
03200 IF(R9.NE.0)GO TO 1
03300 C R8=0 AND R9=NUM -- PUTS NUMBER OUTSIDE BEAM(FOR TRIPLETS, ETC.)
03400 204 IF(R9.NE.0)R9=RHORZ(R9)
03500 IF(J7)GO TO 201
03600 200 IF(J10.LT.10)GO TO 91
03700 C NEXT FOR INNER, PARTIAL BEAMS
03800 R8=RHORZ(R8)
03900 R10=AMOD(R10,10.)
04000 GO TO(2,3,4),J10/10
04100 2 RH=R9+RX
04200 GO TO 1
04300 3 R8=R9-RX
04400 C 10=SHORT PARTIAL LFT→RT., 20=RT.←LFT, 30=TO POS IN P8
04500 4 RH=R8
04600 C LEFT INNER POS.
04700 GO TO 1
04800 201 J7=-J7
04900 C P8=WIDTH OF TREM. P9=0(SANS OTHER BEAMS) OR =POS.3, P10=DISP.
05000 CALL NOZERO(R10)
05100 C ALWAYS AT LEAST 1 IN DISPLACEMENT
05200 J10=30
05300 C TO ACTIVATE PARTIAL BEAM SECTION
05400 IF(J9.NE.0)GO TO 202
05500 C NEXT FOR TREM. WITHOUT OTHER BEAMS.
05600 RH=-1
05700 IF(J7.GE.20)RH=-RH
05800 CC203 R4=R4+R10*RH
05900 CC CALL CENTX
06000 R5=R4+RH
06100 R9=R3
06200 R6=R3+22.*RMINI
06300 202 IF(R8.EQ.0)R8=4.
06400 RX=R8*RMINI*2.98
06500 RH=R9+RX
06600 R9=R9-RX
06700 GO TO 1
06800
06900 91 IF(J8.EQ.0)GO TO 1
07000 IF(J8.GT.0)GO TO 92
07100 C FOR J8=-(10+DN) OR -(20+DN)
07200 R9=R3+RX
07300 IF(J8.LE.-20)R9=R6-RX
07400 192 J8=-J8
07500 92 IF(J10.EQ.0)J10=MOD(J8,10)
07600 CC??? 4/75 J8=J8-J10
07700 IF(J10.EQ.0)J10=1
07800 R10=J10
07900 C IF P8 NEG, P9 IS AUTOMATIC, ALSO P10 IF NEEDED.
08000 1 IF(IABS(J4).LT.100)GO TO 97
08100 RMINI=.6*RSTJ2
08200 R5=AMOD(R5,100.0)
08300 C SPACE BETWEEN BEAMS
08400 97 RJ=RMINI*11.
08500 RW=RMINI*RHGT
08600 C DIST. UP OR DOWN FROM NOTE HEAD.
08700 RJA=R10*RJ
08800 C DISPLACEMENT
08900 RD=R9
09000 C POSITION 3
09100 RJX=CENTR-RW+RJA
09200 C FINAL HEIGHT OF LEFT SIDE
09300 C NEG R7=TREMOLO
09400 RX=MOD(J7,10)
09500 JJ2=J7-20
09600 RA=R6
09700 C HORIZANTAL DIST.
09800 RJY=R5*RST7+POS-RST18-RW+RJA
09900 C VERTICAL POS OF RIGHT SIDE.
10000 RW=R14*RMINI
10100 RY=1.
10200 IF(J7.GE.20)GO TO 98
10300 C JUMP IF STEMS ARE DOWN
10400 RY=-RY
10500 C FOR THICKENING INCR.
10600 JJ2=J7-10
10700 RJ=-RJ
10800 RJA=RMINI*R2HGT-2.*RJA
10900 RJX=RJX+RJA
11000 RJY=RJY+RJA
11100 R3Q=R3Q+RW
11200 C POSITION 1
11300 RA=RA+RW
11400 C POSITION 2
11500 RD=RD+RW
11600 C******************************
11700 RH=RH+RW
11800 98 RSTJ2=RSTJ2*RBM
11900 C RBM BRINGS LINES OF BEAMS CLOSER TOGETHER. (=.83)
12000 93 IF(JJ2.GT.RX)GO TO 94
12100 IF(J10.GE.10)GO TO 7
12200 C**********************
12300 IF(J8.EQ.0)GO TO 94
12400 R3=RW
12500 IF(J9.EQ.0)GO TO 292
12600 IF(J8.GE.20)GO TO 193
12700 293 RX=R3Q-RD
12800 GO TO 194
12900 7 RHX=RH-R3Q
13000 R3=RD-R3Q
13100 GO TO 292
13200 193 RX=RD-RA
13300 194 R3=ABS(RX)
13400 292 DISX=ABS(R3Q-RA)
13500 HGT=RJX-RJY
13600 IF(J10.GE.10)HGT1=HGT*RHX/DISX
13700 C**********************
13800 R3=R3/DISX
13900 195 HGT=HGT*R3
14000 196 L=J8/10
14100 J8=0
14200 IF(J10.GE.10)GO TO 8
14300 C***************
14400 IF(L.EQ.1)GO TO 95
14500 C BEAM LFT=1, RT=2 (PARAM 8=10 OR 20)
14600 R3Q=RD
14700 RJX=RJY+HGT
14800 GO TO 94
14900 C**************
15000 8 R3Q=RH
15100 RA=RD
15200 RJY=RJX-HGT
15300 RJX=RJX-HGT1
15400 GO TO 94
15500 95 RA=RD
15600 RJY=RJX-HGT
15700 94 L=7.*RMINI
15800 930 RC=0
15900 C MINI LINES HAVE .2 SMALLER BEAMS. MAYBE CHANGE THIS??
16000 CALL LINES(R3Q,RJX,3)
16100 DO 941 K=1,L
16200 CALL BMS
16300 IF(PLT.GE.0)GO TO 940
16400 RC=RC+RY
16500 C FOR THICKENING.
16600 CALL BMS
16700 CALL EXCH(RA,R3Q)
16800 941 CALL EXCH(RJY,RJX)
16900 CALL BMS
17000 C DRAWS 5 LINES FOR BEAMS.
17100 940 JJ2=JJ2-1
17200 IF(JJ2.LE.0)GO TO 942
17300 C IF P7=10 OR 20 ONE BEAM WILL APPEAR.
17400 RJY=RJY+RJ
17500 RJX=RJX+RJ
17600 GO TO 930
17700
17800 942 IF(R8.NE.0)RETURN
17900 IF(R9.EQ.0)RETURN
18000 IF(R10.GE.30)RETURN
18100 C FOR NUMBERS OUTSIDE BEAMS
18200 RSTJ2=RMINI
18300 RD=-10.
18400 IF(R7.LT.20)RD=8.3
18500 943 J3=R3Q+(RA-R3Q)/2.
18600 R6=1.
18700 CC *** DONE IN CENTX *** R4=AMOD(R4,100.)
18800 R4=R4+(R5-R4)/2.+RD
18900 R7=1
19000 C ITALICS
19100 CALL MAKNUM(R9)
19300 END
23700
23800 CC SUBROUTINE BMS
23900 CC COMMON/STF/RSTFAC(-3/4),RSTJ2/BM/RA,RC,RJY
24000 CC CALL LINES(RA,RJY+RC*RSTJ2,2)
24100 CC END
24200
24300 SUBROUTINE METER
24400 COMMON R2,JA,CENTR,J2,RJQ(20),J3,JQ(19)/STF/RSTFAC(-3/4),RSTJ2
24500 COMMON/POSI/STFF(-3/4),JJ2,POS
24600 EQUIVALENCE (R4,RJQ(2)),(R7,RJQ(5)),(R6,RJQ(4)),(R5,RJQ(3))
24700 1,(R8,RJQ(6)),(RX3,RJQ(20)),(J10,JQ(7)),(J7,JQ(5)),(R9,RJQ(7))
24800
24900 C PARAMS 18 / STF / POS / VERT HGT./ TOP NUM/ BOT NUM/ SIZE FAC.
25000
25100 CALL NOZERO(R7)
25200 JZ=J3
25300 RY=R4+8.*R7
25400 C HEIGHT
25500 RW=R6
25600 C BOTTOM NUM
25700 C P5=TOP NUM
25800 R6=R7
25900 RR6=R6
26000 C SIZE
26100 C FOR BDR40 -- OR =1
26200 M=0
26300 R4=RY
26400 2 R7=0
26500 C R7=0 FOR BDR FONT??
26600 CC IF(R5.NE.99)GO TO 1
26700 IF(R5.LT.90)GO TO 3
26800 C 99 AS METER = 'C' 98=ALLA BREVE (CUT TIME)
26900 M=-1
27000 IF(R5.NE.98)GO TO 4
27100 C NEXT FOR LINE THROUGH C.
27200 RZ=R6
27300 RY=R4
27400 RA=POS
27500 R6=RX3
27600 C TO LINE UP WITH R3
27700 J10=2
27800 C FOR THICK LINE
27810 CC R5=9.8+R4
27900 CC R4=R4+4.2
28000 R4=R4-3.8
28050 R5=R4+5.6
28100 J7=0
28200 R8=0
28300 CALL ITMSUB
28400 POS=RA
28500 R4=RY
28600 R6=RZ
28700 C GET BACK THE RIGHT PARAMS.
28800
28900 4 R5=9999.
29000 GO TO 3
29100 C TO CENTER 12S AND 16S
29200 3 CALL MAKNUM(R5)
29300 IF(M)RETURN
29400 C STICK AROUND FOR BOTTOM NUM
29500 M=-1
29600 R4=RY-4.*RR6
29700 R6=RR6
29800 R5=RW
29900 C GET BOTTOM NUM
30000 J3=JZ
30100 R8=0
30200 GO TO 2
30300 END
30400
30500 CF SUBROUTINE RNOTE(X)
30600 CF COMMON /PTR/PWDS(250),ITEM,L,I,IX/XRN/RN(4000)
30700 CF X=RN(IFIX(PWDS(IFIX(AMOD(X,1000.))))+2)
30800 CF END
30900
31000 SUBROUTINE MAKNUM(RNUM)
31100 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/STF/RSTFAC(-3/4),RSTJ2
31200 EQUIVALENCE (J3,JQ(1)),(R4,RJQ(2)),(R8,RJQ(6)),(R7,RJQ(5))
31300 1,(R6,RJQ(4)),(R5,RJQ(3)),(R7,RJQ(5)),(JQ(15),B),(JQ(16),C)
31400 1 ,(J8,JQ(6)),(J10,JQ(8)),(R3,RJQ(1)),(J5,JQ(3)),(RJY,JQ(19))
31500 1 ,(J7,JQ(5)),(J6,JQ(4)),(R9,RJQ(7))
31600 DATA RS/10.0/,RBX/1.0/
31700 RB8=R8
31800 J3X=J3
31900 C P7=0=BDR40; =1=BDI40; =2=PRIM.
32000 CALL NOZERO(R6)
32100 R5=R6
32200 C UPPER CASE - BDR40
32300 R6=48000000.0+(R7+50.)*10000.
32400 R7=99999999.0
32500 C BLANKS
32600 R8=R7
32700 IF(RNUM.NE.9999.)GO TO 2
32800 C NEXT FOR 'C'OMMON TIME
32900 RNUM=12.
33000 C MAKES A 'C'
33100 R4=R4-2.2
33200 C .2 FOR BAD POS. OF LETTERS
33300 GO TO 4
33400
33500 2 ONE=0
33600 RNUM=IFIX(RNUM)
33700 C SO MISTAKES (i.e. 2.2) WON'T BREAK THE PROG.
33800 IF(RNUM.EQ.1.)ONE=3.
33900 IF(RNUM.GT.9.)GO TO 3
34000 C JUMP FOR 2 OR 3 DIGIT NUMBER
34100 4 R6=R6+RNUM*100.+47.
34200 C PUTS BLANK ON END (.47)
34300 GO TO 1
34400
34500 3 RJY=10.
34600 IF(RNUM.GE.100.)RJY=100.
34700 B=IFIX(RNUM/RJY)
34800 C=AMOD(RNUM,RJY)
34900 IF(RNUM.LT.100)GO TO 7
35000 D=IFIX(C/10.)
35100 C=AMOD(C,10.)
35200 IF(C.EQ.1.)ONE=ONE+3.
35300 R7=C*1000000.+999999.0
35400 C=D
35500 7 R6=R6+B*100.+C
35600 IF(B.EQ.1.)ONE=ONE+3.
35700 IF(C.EQ.1.)ONE=ONE+3.
35800 B=R5
35900 IF(RNUM.GE.100.)B=B*2
36000 J3=J3-RS*RSTJ2*B
36100 C FOR 2 DIGIT NUMBER
36200 CCC IF(RNUM.GE.20.)GO TO 6
36300 CCC IF(JA.EQ.18)GO TO 6
36400 CCC RJY=5.6
36500 CCC IF(RNUM.GT.11.)RJY=3.
36600 C ADJUSTS FOR 11, ETC.
36700 CCC J2=J2+RJY*R5*RSTJ2
36800 CC6 J3=J2
36900 1 J3=J3+ONE*R5*RSTJ2
37000 C CENTERS THE NUMBER '1'
37100 CALL ALPHA
37200 J3=J3X
37300 IF(RB8.EQ.0)RETURN
37400 C NEXT FOR CIRCLES AND BOXES AROUND NUMBERS.
37500 R3=J3-R5
37600 IF(J10.EQ.0)J10=1
37700 C USE J10 FOR EVEN THICKER BOX AND CIRC.
37800 IF(RNUM.GT.9)R3=R3+R5*RBX
37900 C TO SET CENTER
38000 IF(RB8.EQ.2)GO TO 5
38100 R4=R4+R5+.1+.05/R5
38200 C END OF ABOVE IS FOR SMALL CIRCLES.
38300 B=4.5
38400 IF(RNUM.GE.100.)B=5.5
38500 R5=R5*B
38600 JA=12
38700 J6=0
38800 J7=0
38900 J8=J10
39000 CALL CENTX
39100 CALL SLUR
39200 RETURN
39300
39400 5 JA=4
39500 B=6
39600 R9=0
39700 IF(RNUM.LT.100.)GO TO 8
39800 B=9.
39900 R9=R5*6.
40000 C MAKES RECTANGLE IF ≥100
40100 8 R4=R4+R5*.7+.1
40200 R8=R5*B
40300 J5=50
40400 CALL ITMSUB
40500 C RETURNS ORIG. HORIZ. POS.
40600 END
40700 C MAKES ONLY 1 TO 3 DIGIT NUMS NOW. EXPAND LATER.
40800
40900 CC FUNCTION IABS(N)
41000 C BECAUSE IABS IN LIB40 HAS A BUG.
41100 CC IABS=N
41200 CC IF(N)IABS=-N
41300 CC END
41400
41500 CF SUBROUTINE DRWNT(RMINI)
41600 CF COMMON /STF/RSTFAC(-3/4),RSTJ2
41700 CF COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
41800 CF EQUIVALENCE (JE,JQ(3)),(RJD,RJQ(2)),(R6,RJQ(4)),
41900 CF 1 (JG,JQ(5)),(R7,RJQ(5)),(RJE,RJQ(3)),(RJZ,RJQ(20))
42000 CF 1 ,(JI,JQ(7)),(R9,RJQ(7)),(JH,JQ(6))
42100 CF RJX=CENTR
42200 CF JH=0
42300 C JH=0 SO IT WILL FILL. (P8 IN 'CLEFS')
42400 CC CENTR=CENTR-21.*RSTJ2
42500 CF RA=R6
42600 CF R6=.5*RMINI/RSTJ2
42700 CF R7=R6
42800 CF RJD=RJZ-3
42900 CCXX IF(RSTJ2.NE.RMINI)RJD=RJZ+.43*(RJZ-3.)-.3
43000 C ADJUSTS POSITION FOR MINI ACCIDENTALS (..??!!)
43100 CF JI=0
43200 CF CALL CLEFS
43300 CF JI=R9
43400 C ↑↑↑↑↑↑ NEEDED??
43500 C FIX THIS???? ↑↑↑↑↑
43600 C FOR WHITE NOTES AND ACCIS ON PLOTTER.
43700 CF CENTR=RJX
43800 CF R6=RA
43900 CF R7=JG
44000 CF JE=RJE
44100 CF END
44200
44300 CC FUNCTION RHORZ(R)
44400 CC RHORZ=R*5.96-596.
44500 CC END
44600
44700 CF SUBROUTINE RDRAW(I,S,XY,X,R3,CENTR,RMINI)
44800 C TO X,Y INTO ONE WORD
44900 CF DIMENSION XY(1)
45000 CF DO 2 K=I,IFIX(S)
45100 CF L=2
45200 CF Y=XY(K)
45300 CF IF(Y.LT.1000.)GO TO 3
45400 CF L=3
45500 CF Y=Y-1000.
45600 C >1000 = INVIS. LINE
45700 CF3 M=Y
45800 CF Y=(Y-M)*1000.
45900 CF IF(Y.GT.100.)Y=100-Y
46000 C Y NUMBERS .GT.100 ARE NEG.
46100 CF B=Y*X+CENTR
46200 CF IF(M.GT.60)M=100-M
46300 CF A=M*RMINI+R3
46400 CF2 CALL LINES(A,B,L)
46500 CF END
46600
46700 CC FUNCTION EEXP(X,Y)
46800 CC EEXP=X**Y
46900 CC END